#lang racket

(provide set set-union set-add set-subtract set-contains? set-fold set->list subset-score)

(define (node l v r) (list l v r))
(define (left node) (car node))
(define (right node) (caddr node))
(define (value node) (cadr node))

(define (btree-insert t v)
  (cond ((null? t) (node '() v '()))
        ((= v (value t)) t)
        ((< v (value t)) (node (btree-insert (left t) v) (value t) (right t)))
        (else (node (left t) (value t) (btree-insert (right t) v)))))

(define (btree-remove t v)
  (cond ((null? t) t)
        ((= v (value t))
         (cond
          ((and (null? (left t)) (null? (right t))) '())
          ((null? (left t)) (right t))
          ((null? (right t)) (left t))
          (else (rotate (left t) (lambda (x) x) (right t)))))
        ((< v (value t)) (node (btree-remove (left t) v) (value t) (right t)))
        (else (node (left t) (value t) (btree-remove (right t) v)))))

(define (rotate t parent tree-right)
  (if (null? (right t))
      (list (parent (left t)) (value t) tree-right)
      (rotate (right t) (lambda (hole) (parent (list (left t) (value t) hole))) tree-right)))

(define (btree-contains? t v)
  (cond ((null? t) #f)
        ((= v (value t)) #t)
        ((< v (value t)) (btree-contains? (left t) v))
        ((> v (value t)) (btree-contains? (right t) v))
        (else #f)))

(define (btree->list t)
  (define (btree->list-aux t m)
    (cond
      ((null? t) m)
      (else
       (let* ((r (btree->list-aux (right t) m))
              (c (cons (value t) r)))
         (btree->list-aux (left t) c)))))
  (btree->list-aux t '()))

(define (btree-fold fn init t)
  (define (btree-fold-aux t m)
    (cond
      ((null? t) m)
      (else
       (let* ((l (btree-fold-aux (left t) m))
              (c (fn l (value t))))
         (btree-fold-aux (right t) c)))))
  (btree-fold-aux t init))

(define (btree-union a b)
  (btree-fold (lambda (m c) (btree-insert m c)) a b))

(define (btree-subtract a b)
  (btree-fold (lambda (m c) (btree-remove m c)) a b))

(define (set . xs)
  (define (set-aux xs m)
    (if (null? xs)
        m
        (set-aux (cdr xs) (btree-insert m (car xs)))))
  (set-aux xs '()))

(define set-add btree-insert)
(define set-union btree-union)
(define set-subtract btree-subtract)
(define set-contains? btree-contains?)
(define set-fold btree-fold)
(define set->list btree->list)

(define (subset-score-lists s1 s2)
  (define (subset-score-aux s1 s2 score)
    (cond
     ((null? s2) score)
     ((null? s1) (if (null? s2) score 0))
     ((> (car s1) (car s2)) 0)
     ((< (car s1) (car s2)) (subset-score-aux (cdr s1) s2 score))
     ((= (car s1) (car s2)) (subset-score-aux (cdr s1) (cdr s2) (+ score 1)))))
  (subset-score-aux s1 s2 0))

(define (subset-score s1 s2)
  (subset-score-lists (btree->list s1) (btree->list s2)))
